perm filename POV3.2[EAL,HE] blob
sn#676477 filedate 1982-09-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00010 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 {$NOMAIN Auxilliary statement parsers }
C00006 00003 function enableParse(st: statementp): boolean external
C00008 00004 function stopParse(st: statementp): boolean external
C00010 00005 function retryParse(st: statementp): boolean external
C00011 00006 function wristParse(st: statementp): boolean external
C00013 00007 (* Aux routine needed by requireParse: fileOpen *)
C00015 00008 (* Aux routine needed by PMAIN: file1Open *)
C00017 00009 function requireParse(st: statementp): boolean external
C00021 00010 function defineParse(st: statementp): boolean external
C00026 ENDMK
C⊗;
{$NOMAIN Auxilliary statement parsers }
%include palhdr.pas;
{ Externally defined routines from elsewhere: }
(* From ALLOC *)
procedure relNode(n: nodep); external;
function newVaridef: varidefp; external;
(* From PROOT *)
procedure errprnt; external;
function copyToken: tokenp; external;
procedure getToken; external;
procedure getDelim(char: ascii); external;
procedure ppFlush; external;
function ov3ExprParse: nodep; external;
(* From PAUX1 *)
function upperCase(c: ascii): ascii; external;
function makeNewVar(vartype: datatypes; vid: identp): varidefp; external;
function makeUVar(vartype: datatypes; vid: identp): varidefp; external;
function varLookup(id: identp): varidefp; external;
function getDtype(n: nodep): datatypes; external;
function checkArg(n: nodep; d: datatypes): nodep; external;
(* From PAUX2 *)
procedure relExpr(n: nodep); external;
function evalOrder(what,last: nodep; pcons: boolean): nodep; external;
procedure checkdim(n,d: nodep); external;
(* Display-related Routines *)
procedure ppLine; external;
procedure ppOutNow; external;
procedure ppChar(ch: ascii); external;
procedure pp5(ch: c5str; length: integer); external;
procedure pp10(ch: cstring; length: integer); external;
procedure pp10L(ch: cstring; length: integer); external;
procedure pp20(ch: c20str; length: integer); external;
procedure pp20L(ch: c20str; length: integer); external;
procedure ppInt(i: integer); external;
procedure ppReal(r: real); external;
procedure ppStrng(length: integer; s: strngp); external;
procedure ppDtype(d: datatypes); external;
procedure pOv3Get; external;
procedure pOv3Get; begin end;
function enableParse(st: statementp): boolean; external;
function enableParse;
var b: boolean; v: varidefp;
begin (* enable & disable statements *)
b := false;
st↑.cmonlab := nil;
with curToken do
begin
getToken; (* get the label of the cmon to enable/disable *)
if ttype = identtype then (* check that it's really a label *)
begin
v := varLookup(id);
if v = nil then (* need to define it *)
begin
v := makeUVar(labeltype,id);
st↑.cmonlab := v;
pp20L('Undeclared identifie',20); pp20('r defined to be a la',20);
pp5('bel. ',4);
errprnt;
end
else if v↑.vtype = labeltype then st↑.cmonlab := v (* ok *)
else b := true (* no good *)
end
else
begin
backup := true;
if curCmon = nil then b := true; (* no good, unless in a cmon body *)
end;
end;
if b then
begin (* no good *)
pp20L('Need a label here. ',18); ppFlush;
errprnt;
end;
enableParse := b;
end;
function stopParse(st: statementp): boolean; external;
function stopParse;
var d: datatypes; b: boolean;
begin (* stop statement *)
with st↑ do
begin
cf := ov3ExprParse; (* what are we stopping? *)
if cf = nil then (* use default = cf of current motion (if any) *)
begin
if curMotion = nil then
begin
pp20L('Need to specify what',20); pp10(' to Stop ',8);
errprnt;
end
end
else
begin (* make sure it's a variable *)
d := getDtype(cf);
b := true;
with cf↑ do
if ((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop)) then (* a variable? *)
if d = frametype then b := false (* assume any frame var is ok *)
else if (d = svaltype) and (ntype = leafnode) then
if (vari↑.level = 0) and (* check for scalar devices *)
(vari↑.offset in [2,6,10,14,16,20]) then b := false;
(* offsets: 2=bhand, 6=yhand, 10=ghand, 14=rhand, 16=driver, 20=vise *)
if b then
begin (* no good *)
pp20L('Need a device variab',20); pp10('le here. ',8);
errprnt;
relExpr(cf);
cf := nil;
end
end;
clauses := nil;
end;
stopParse := false; (* always ok *)
end;
function retryParse(st: statementp): boolean; external;
function retryParse;
begin (* retry statement *)
if curErrhandler <> nil then
begin
st↑.rparent := curErrhandler;
st↑.rcode := curMotion;
st↑.olevel := moveLevel;
end
else
begin (* no good *)
st↑.rparent := nil;
st↑.rcode := nil;
pp20L('RETRY can only be in',20); pp20(' body of error handl',20); pp5('er. ',3);
errprnt;
end;
retryParse := false; (* always ok *)
end;
function wristParse(st: statementp): boolean; external;
function wristParse;
var b: boolean; lexp: nodep;
begin (* wrist statement *)
b := false;
lexp := nil;
with st↑ do
begin
getDelim('('); (* get opening "(" *)
fvec := checkarg(ov3ExprParse,vectype);
checkdim(fvec,forcedim↑.dim);
with fvec↑ do (* make sure it's a variable *)
if (ntype = exprnode) and (op = arefop) then
lexp := evalorder(arg2,lexp,true) (* deal with subscripts *)
else if not ((ntype = leafnode) and (ltype = varitype)) then (* no good *)
begin
b := true;
pp20L('Need a variable here',20); ppChar('.'); ppFlush;
errprnt;
end;
getDelim(','); (* get separating "," *)
tvec := checkarg(ov3ExprParse,vectype);
checkdim(tvec,torquedim↑.dim);
with tvec↑ do (* make sure it's a variable *)
if (ntype = exprnode) and (op = arefop) then
lexp := evalorder(arg2,lexp,true) (* deal with subscripts *)
else if not ((ntype = leafnode) and (ltype = varitype)) then (* no good *)
begin
b := true;
pp20L('Need a variable here',20); ppChar('.'); ppFlush;
errprnt;
end;
getDelim(')'); (* get closing ")" *)
exprs := lexp;
end;
wristParse := b;
end;
(* Aux routine needed by requireParse: fileOpen *)
procedure fileOpen(len: integer; str: strngp); external;
procedure fileOpen;
var i,j: integer; fname: packed array [1..30] of char;
begin
j := 0;
if len > 30 then len := 30;
for i := 1 to len do
begin
if j < 10 then j := j + 1 else begin j := 1; str := str↑.next end;
fname[i] := str↑.ch[j];
end;
for i := len + 1 to 30 do fname[i] := ' ';
case filedepth of
1: reset(file1,fname,'.AL',i);
2: reset(file2,fname,'.AL',i);
3: reset(file3,fname,'.AL',i);
4: reset(file4,fname,'.AL',i);
5: reset(file5,fname,'.AL',i);
end;
if i < 0 then (* couldn't open file - complain *)
begin
pp20L('Can''t open file ',15);
errprnt;
end;
end;
(* Aux routine needed by PMAIN: file1Open *)
procedure file1Open (fn: c20str); external;
procedure file1Open ;
begin reset(file1,fn,'.AL'); end;
(* I hope this is used ONLY by PMAIN!! *)
function requireParse(st: statementp): boolean; external;
function requireParse;
var b: boolean; chr: ascii; i,j: integer; s: strngp; n: nodep;
begin (* require statement *)
b := false;
n := nil;
with st↑, curToken do
begin
getToken; (* see what type of require we have *)
if (ttype = reswdtype) and (rtype = filtype) and (filler = errmodestype) then
begin
rfil := false;
getToken; (* get the error mode values *)
if ttype <> constype then b := true
else begin n := cons; if cons↑.ltype <> strngtype then b := true; end;
if b then
begin
backup := true;
pp20L('Expecting a string h',20); pp5('ere ',3);
errprnt;
end
else
begin
rfils := cons↑.str;
rfilen := cons↑.length;
j := 1;
s := rfils;
for i := 1 to rfilen do
begin
chr := upperCase(s↑.ch[j]);
if j < 10 then j := j + 1 else begin j := 1; s := s↑.next end;
if chr = 'F' then dimCheck := false; (* only mode we know about *)
end
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = sourcefiletype) then
begin
rfil := true;
getToken; (* get the name of the file *)
if ttype <> constype then b := true
else begin n := cons; if cons↑.ltype <> strngtype then b := true; end;
if b then
begin
backup := true;
pp20L('Need a file name her',20); ppChar('e');
errprnt;
end
else
begin
rfils := cons↑.str;
rfilen := cons↑.length;
if filedepth < 5 then
begin
filedepth := filedepth + 1;
fileopen(rfilen,rfils);
getToken; (* now try to skip over the E directory *)
if (ttype = delimtype) and (ch = ';') then
begin
semiseen := true;
getToken;
end;
backup := true;
end
else
begin
pp20L('Can only nest files ',20); pp20('5 deep - ignoring re',20);
pp5('quire',5);
errprnt;
end
end;
end
else
begin
pp20L('Unknown require opti',20); pp5('on ',2);
errprnt;
b := true;
end;
if n <> nil then relNode(n);
end;
requireParse := b;
end;
function defineParse(st: statementp): boolean; external;
function defineParse;
var oldExpandmacros,b: boolean; v,vp: varidefp; t,tp: tokenp;
begin (* define statement *)
b := false;
oldExpandmacros := expandmacros;
expandmacros := false;
with st↑, curToken do
begin
getToken; (* get the name of the macro *)
if ttype <> identtype then
begin
b := true;
pp20L('Need an identifier h',20); pp5('ere. ',5);
errprnt;
end
else
begin
v := makeNewVar(mactype,id);
v↑.mdef := st;
macname := v;
v := nil;
getToken;
if (ttype = delimtype) and (ch = '(') then (* get macro args *)
begin
repeat
getToken; (* get the parameter's name *)
if ttype <> identtype then
begin
b := true;
pp20L('Need an identifier h',20); pp5('ere. ',5);
errprnt;
backup := true;
end
else
begin
if v = nil then begin v := newVaridef; vp := v end
else begin vp↑.next := newVaridef; vp := vp↑.next end;
with vp↑ do begin vtype := macargtype; name := id; end;
end;
getToken;
until b or (ttype <> delimtype) or (ch <> ',');
vp↑.next := nil;
backup := true;
getDelim(')'); (* get closing ")" *)
end
else backup := true;
mpars := v;
getToken; (* get "=" *)
if (ttype <> reswdtype) or (rtype <> optype) or (op <> seqop) then
begin
pp20L('Need an "=" here ',16);
errprnt;
backup := true;
end;
getToken; (* see if simple body or \...\ *)
if (ttype = delimtype) and (ch = '\') then
begin
t := nil;
repeat
getToken;
if (ttype <> delimtype) or (ch <> '\') then
begin
if t = nil then begin t := copyToken; tp := t end
else begin tp↑.next := copyToken; tp := tp↑.next end;
if ttype = identtype then (* see if it's a macro parameter *)
begin
v := mpars;
while v <> nil do (* run through parameter list *)
if v↑.name <> id then v := v↑.next (* try next *)
else
begin
tp↑.ttype := macpartype; (* yes - indicate that it is *)
tp↑.mpar := v;
v := nil;
end;
end;
end
until (ttype = delimtype) and (ch = '\');
end
else begin t := copyToken; tp := t end;
if tp <> nil then tp↑.next := nil;
macdef := t;
getToken;
end;
if (ttype = delimtype) and (ch = ',') then
begin (* set things up for another define statement *)
semiseen := true;
ttype := reswdtype;
rtype := stmnttype;
stmnt := definetype;
end;
end;
backup := true;
expandmacros := oldExpandmacros;
defineParse := b;
end;